home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_emacs.idb / usr / freeware / share / emacs / 19.34 / lisp / nndoc.el.z / nndoc.el
Encoding:
Text File  |  1998-10-28  |  14.9 KB  |  477 lines
  1. ;;; nndoc.el --- single file access for Gnus
  2. ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  5. ;;     Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
  6. ;; Keywords: news
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;;; Code:
  28.  
  29. (require 'nnheader)
  30. (require 'message)
  31. (require 'nnmail)
  32. (require 'nnoo)
  33. (eval-when-compile (require 'cl))
  34.  
  35. (nnoo-declare nndoc)
  36.  
  37. (defvoo nndoc-article-type 'guess
  38.   "*Type of the file.
  39. One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
  40. `mime-digest', `standard-digest', `slack-digest', `clari-briefs' or
  41. `guess'.")
  42.  
  43. (defvoo nndoc-post-type 'mail
  44.   "*Whether the nndoc group is `mail' or `post'.")
  45.  
  46. (defvar nndoc-type-alist 
  47.   `((mmdf 
  48.      (article-begin .  "^\^A\^A\^A\^A\n")
  49.      (body-end .  "^\^A\^A\^A\^A\n"))
  50.     (news
  51.      (article-begin . "^Path:"))
  52.     (rnews
  53.      (article-begin . "^#! *rnews +\\([0-9]+\\) *\n")
  54.      (body-end-function . nndoc-rnews-body-end))
  55.     (mbox 
  56.      (article-begin . 
  57.             ,(let ((delim (concat "^" message-unix-mail-delimiter)))
  58.                (if (string-match "\n\\'" delim)
  59.                (substring delim 0 (match-beginning 0))
  60.              delim)))
  61.      (body-end-function . nndoc-mbox-body-end))
  62.     (babyl 
  63.      (article-begin . "\^_\^L *\n")
  64.      (body-end . "\^_")
  65.      (body-begin-function . nndoc-babyl-body-begin)
  66.      (head-begin-function . nndoc-babyl-head-begin))
  67.     (forward
  68.      (article-begin . "^-+ Start of forwarded message -+\n+")
  69.      (body-end . "^-+ End of forwarded message -+$")
  70.      (prepare-body . nndoc-unquote-dashes))
  71.     (clari-briefs
  72.      (article-begin . "^ \\*")
  73.      (body-end . "^\t------*[ \t]^*\n^ \\*")
  74.      (body-begin . "^\t")
  75.      (head-end . "^\t")
  76.      (generate-head . nndoc-generate-clari-briefs-head)
  77.      (article-transform . nndoc-transform-clari-briefs))
  78.     (slack-digest
  79.      (article-begin . "^------------------------------*[\n \t]+")
  80.      (head-end . "^ ?$")
  81.      (body-end-function . nndoc-digest-body-end)
  82.      (body-begin . "^ ?$")
  83.      (file-end . "^End of")
  84.      (prepare-body . nndoc-unquote-dashes))
  85.     (mime-digest
  86.      (article-begin . "")
  87.      (head-end . "^ ?$")
  88.      (body-end . "")
  89.      (file-end . ""))
  90.     (standard-digest
  91.      (first-article . ,(concat "^" (make-string 70 ?-) "\n\n+"))
  92.      (article-begin . ,(concat "\n\n" (make-string 30 ?-) "\n\n+"))
  93.      (prepare-body . nndoc-unquote-dashes)
  94.      (body-end-function . nndoc-digest-body-end)
  95.      (head-end . "^ ?$")
  96.      (body-begin . "^ ?\n")
  97.      (file-end . "^End of .*digest.*[0-9].*\n\\*\\*\\|^End of.*Digest *$"))
  98.     (guess 
  99.      (guess . nndoc-guess-type))
  100.     (digest
  101.      (guess . nndoc-guess-digest-type))
  102.     ))
  103.  
  104.  
  105.  
  106. (defvoo nndoc-file-begin nil)
  107. (defvoo nndoc-first-article nil)
  108. (defvoo nndoc-article-end nil)
  109. (defvoo nndoc-article-begin nil)
  110. (defvoo nndoc-head-begin nil)
  111. (defvoo nndoc-head-end nil)
  112. (defvoo nndoc-file-end nil)
  113. (defvoo nndoc-body-begin nil)
  114. (defvoo nndoc-body-end-function nil)
  115. (defvoo nndoc-body-begin-function nil)
  116. (defvoo nndoc-head-begin-function nil)
  117. (defvoo nndoc-body-end nil)
  118. (defvoo nndoc-dissection-alist nil)
  119. (defvoo nndoc-prepare-body nil)
  120. (defvoo nndoc-generate-head nil)
  121. (defvoo nndoc-article-transform nil)
  122.  
  123. (defvoo nndoc-status-string "")
  124. (defvoo nndoc-group-alist nil)
  125. (defvoo nndoc-current-buffer nil
  126.   "Current nndoc news buffer.")
  127. (defvoo nndoc-address nil)
  128.  
  129. (defconst nndoc-version "nndoc 1.0"
  130.   "nndoc version.")
  131.  
  132.  
  133.  
  134. ;;; Interface functions
  135.  
  136. (nnoo-define-basics nndoc)
  137.  
  138. (deffoo nndoc-retrieve-headers (articles &optional newsgroup server fetch-old)
  139.   (when (nndoc-possibly-change-buffer newsgroup server)
  140.     (save-excursion
  141.       (set-buffer nntp-server-buffer)
  142.       (erase-buffer)
  143.       (let (article entry)
  144.     (if (stringp (car articles))
  145.         'headers
  146.       (while articles
  147.         (when (setq entry (cdr (assq (setq article (pop articles))
  148.                      nndoc-dissection-alist)))
  149.           (insert (format "221 %d Article retrieved.\n" article))
  150.           (if nndoc-generate-head
  151.           (funcall nndoc-generate-head article)
  152.         (insert-buffer-substring
  153.          nndoc-current-buffer (car entry) (nth 1 entry)))
  154.           (goto-char (point-max))
  155.           (or (= (char-after (1- (point))) ?\n) (insert "\n"))
  156.           (insert (format "Lines: %d\n" (nth 4 entry)))
  157.           (insert ".\n")))
  158.  
  159.       (nnheader-fold-continuation-lines)
  160.       'headers)))))
  161.  
  162. (deffoo nndoc-request-article (article &optional newsgroup server buffer)
  163.   (nndoc-possibly-change-buffer newsgroup server)
  164.   (save-excursion
  165.     (let ((buffer (or buffer nntp-server-buffer))
  166.       (entry (cdr (assq article nndoc-dissection-alist)))
  167.       beg)
  168.       (set-buffer buffer)
  169.       (erase-buffer)
  170.       (if (stringp article)
  171.       nil
  172.     (insert-buffer-substring 
  173.      nndoc-current-buffer (car entry) (nth 1 entry))
  174.     (insert "\n")
  175.     (setq beg (point))
  176.     (insert-buffer-substring 
  177.      nndoc-current-buffer (nth 2 entry) (nth 3 entry))
  178.     (goto-char beg)
  179.     (when nndoc-prepare-body
  180.       (funcall nndoc-prepare-body))
  181.     (when nndoc-article-transform
  182.       (funcall nndoc-article-transform article))
  183.     t))))
  184.  
  185. (deffoo nndoc-request-group (group &optional server dont-check)
  186.   "Select news GROUP."
  187.   (let (number)
  188.     (cond 
  189.      ((not (nndoc-possibly-change-buffer group server))
  190.       (nnheader-report 'nndoc "No such file or buffer: %s"
  191.                nndoc-address))
  192.      (dont-check
  193.       (nnheader-report 'nndoc "Selected group %s" group)
  194.       t)
  195.      ((zerop (setq number (length nndoc-dissection-alist)))
  196.       (nndoc-close-group group)
  197.       (nnheader-report 'nndoc "No articles in group %s" group))
  198.      (t
  199.       (nnheader-insert "211 %d %d %d %s\n" number 1 number group)))))
  200.  
  201. (deffoo nndoc-request-type (group &optional article)
  202.   (cond ((not article) 'unknown)
  203.         (nndoc-post-type nndoc-post-type)
  204.         (t 'unknown)))
  205.  
  206. (deffoo nndoc-close-group (group &optional server)
  207.   (nndoc-possibly-change-buffer group server)
  208.   (and nndoc-current-buffer
  209.        (buffer-name nndoc-current-buffer)
  210.        (kill-buffer nndoc-current-buffer))
  211.   (setq nndoc-group-alist (delq (assoc group nndoc-group-alist)
  212.                 nndoc-group-alist))
  213.   (setq nndoc-current-buffer nil)
  214.   (nnoo-close-server 'nndoc server)
  215.   (setq nndoc-dissection-alist nil)
  216.   t)
  217.  
  218. (deffoo nndoc-request-list (&optional server)
  219.   nil)
  220.  
  221. (deffoo nndoc-request-newgroups (date &optional server)
  222.   nil)
  223.  
  224. (deffoo nndoc-request-list-newsgroups (&optional server)
  225.   nil)
  226.  
  227.  
  228. ;;; Internal functions.
  229.  
  230. (defun nndoc-possibly-change-buffer (group source)
  231.   (let (buf)
  232.     (cond 
  233.      ;; The current buffer is this group's buffer.
  234.      ((and nndoc-current-buffer
  235.        (buffer-name nndoc-current-buffer)
  236.        (eq nndoc-current-buffer 
  237.            (setq buf (cdr (assoc group nndoc-group-alist))))))
  238.      ;; We change buffers by taking an old from the group alist.
  239.      ;; `source' is either a string (a file name) or a buffer object. 
  240.      (buf
  241.       (setq nndoc-current-buffer buf))
  242.      ;; It's a totally new group.    
  243.      ((or (and (bufferp nndoc-address)
  244.            (buffer-name nndoc-address))
  245.       (and (stringp nndoc-address)
  246.            (file-exists-p nndoc-address)
  247.            (not (file-directory-p nndoc-address))))
  248.       (push (cons group (setq nndoc-current-buffer 
  249.                   (get-buffer-create 
  250.                    (concat " *nndoc " group "*"))))
  251.         nndoc-group-alist)
  252.       (setq nndoc-dissection-alist nil)
  253.       (save-excursion
  254.     (set-buffer nndoc-current-buffer)
  255.     (buffer-disable-undo (current-buffer))
  256.     (erase-buffer)
  257.     (if (stringp nndoc-address)
  258.         (insert-file-contents nndoc-address)
  259.       (insert-buffer-substring nndoc-address)))))
  260.     ;; Initialize the nndoc structures according to this new document.
  261.     (when (and nndoc-current-buffer
  262.            (not nndoc-dissection-alist))
  263.       (save-excursion
  264.     (set-buffer nndoc-current-buffer)
  265.     (nndoc-set-delims)
  266.     (nndoc-dissect-buffer)))
  267.     (unless nndoc-current-buffer
  268.       (nndoc-close-server))
  269.     ;; Return whether we managed to select a file.
  270.     nndoc-current-buffer))
  271.  
  272. ;; MIME (RFC 1341) digest hack by Ulrik Dickow <dickow@nbi.dk>.
  273. (defun nndoc-guess-digest-type ()
  274.   "Guess what digest type the current document is."
  275.   (let ((case-fold-search t)        ; We match a bit too much, keep it simple.
  276.     boundary-id b-delimiter entry)
  277.     (goto-char (point-min))
  278.     (cond 
  279.      ;; MIME digest.
  280.      ((and
  281.        (re-search-forward
  282.     (concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]"
  283.         "boundary=\"\\([^\"\n]*[^\" \t\n]\\)\"")
  284.     nil t)
  285.        (match-beginning 1))
  286.       (setq boundary-id (match-string 1)
  287.         b-delimiter (concat "\n--" boundary-id "[\n \t]+"))
  288.       (setq entry (assq 'mime-digest nndoc-type-alist))
  289.       (setcdr entry
  290.           (list
  291.            (cons 'head-end "^ ?$")
  292.            (cons 'body-begin "^ ?\n")
  293.            (cons 'article-begin b-delimiter)
  294.            (cons 'body-end-function 'nndoc-digest-body-end)
  295. ;           (cons 'body-end 
  296. ;             (concat "\n--" boundary-id "\\(--\\)?[\n \t]+"))
  297.            (cons 'file-end (concat "\n--" boundary-id "--[ \t]*$"))))
  298.       'mime-digest)
  299.      ;; Standard digest.
  300.      ((and (re-search-forward (concat "^" (make-string 70 ?-) "\n\n") nil t)
  301.        (re-search-forward 
  302.         (concat "\n\n" (make-string 30 ?-) "\n\n") nil t))
  303.       'standard-digest)
  304.      ;; Stupid digest.
  305.      (t
  306.       'slack-digest))))
  307.  
  308. (defun nndoc-guess-type ()
  309.   "Guess what document type is in the current buffer."
  310.   (goto-char (point-min))
  311.   (cond 
  312.    ((looking-at message-unix-mail-delimiter)
  313.     'mbox)
  314.    ((looking-at "\^A\^A\^A\^A$")
  315.     'mmdf)
  316.    ((looking-at "^Path:.*\n")
  317.     'news)
  318.    ((looking-at "#! *rnews")
  319.     'rnews)
  320.    ((re-search-forward "\^_\^L *\n" nil t)
  321.     'babyl)
  322.    ((save-excursion
  323.       (and (re-search-forward "^-+ Start of forwarded message -+\n+" nil t)
  324.        (not (re-search-forward "^Subject:.*digest" nil t))))
  325.     'forward)
  326.    ((let ((case-fold-search nil))
  327.       (re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t))
  328.     'clari-briefs)
  329.    (t 
  330.     'digest)))
  331.  
  332. (defun nndoc-set-delims ()
  333.   "Set the nndoc delimiter variables according to the type of the document."
  334.   (let ((vars '(nndoc-file-begin 
  335.         nndoc-first-article 
  336.         nndoc-article-end nndoc-head-begin nndoc-head-end
  337.         nndoc-file-end nndoc-article-begin
  338.         nndoc-body-begin nndoc-body-end-function nndoc-body-end
  339.         nndoc-prepare-body nndoc-article-transform
  340.         nndoc-generate-head nndoc-body-begin-function
  341.         nndoc-head-begin-function)))
  342.     (while vars
  343.       (set (pop vars) nil)))
  344.   (let* (defs guess)
  345.     ;; Guess away until we find the real file type.
  346.     (while (setq defs (cdr (assq nndoc-article-type nndoc-type-alist))
  347.          guess (assq 'guess defs))
  348.       (setq nndoc-article-type (funcall (cdr guess))))
  349.     ;; Set the nndoc variables.
  350.     (while defs
  351.       (set (intern (format "nndoc-%s" (caar defs)))
  352.        (cdr (pop defs))))))
  353.  
  354. (defun nndoc-search (regexp)
  355.   (prog1
  356.       (re-search-forward regexp nil t)
  357.     (beginning-of-line)))
  358.  
  359. (defun nndoc-dissect-buffer ()
  360.   "Go through the document and partition it into heads/bodies/articles."
  361.   (let ((i 0)
  362.     (first t)
  363.     head-begin head-end body-begin body-end)
  364.     (setq nndoc-dissection-alist nil)
  365.     (save-excursion
  366.       (set-buffer nndoc-current-buffer)
  367.       (goto-char (point-min))
  368.       ;; Find the beginning of the file.
  369.       (when nndoc-file-begin
  370.     (nndoc-search nndoc-file-begin))
  371.       ;; Go through the file.
  372.       (while (if (and first nndoc-first-article)
  373.          (nndoc-search nndoc-first-article)
  374.            (nndoc-search nndoc-article-begin))
  375.     (setq first nil)
  376.     (cond (nndoc-head-begin-function
  377.            (funcall nndoc-head-begin-function))
  378.           (nndoc-head-begin 
  379.            (nndoc-search nndoc-head-begin)))
  380.      (if (and nndoc-file-end
  381.          (looking-at nndoc-file-end))
  382.         (goto-char (point-max))
  383.       (setq head-begin (point))
  384.       (nndoc-search (or nndoc-head-end "^$"))
  385.       (setq head-end (point))
  386.       (if nndoc-body-begin-function
  387.           (funcall nndoc-body-begin-function)
  388.         (nndoc-search (or nndoc-body-begin "^\n")))
  389.       (setq body-begin (point))
  390.       (or (and nndoc-body-end-function
  391.            (funcall nndoc-body-end-function))
  392.           (and nndoc-body-end
  393.            (nndoc-search nndoc-body-end))
  394.           (nndoc-search nndoc-article-begin)
  395.           (progn
  396.         (goto-char (point-max))
  397.         (when nndoc-file-end
  398.           (and (re-search-backward nndoc-file-end nil t)
  399.                (beginning-of-line)))))
  400.       (setq body-end (point))
  401.       (push (list (incf i) head-begin head-end body-begin body-end
  402.               (count-lines body-begin body-end))
  403.         nndoc-dissection-alist))))))
  404.  
  405. (defun nndoc-unquote-dashes ()
  406.   "Unquote quoted non-separators in digests."
  407.   (while (re-search-forward "^- -"nil t)
  408.     (replace-match "-" t t)))
  409.  
  410. (defun nndoc-digest-body-end ()
  411.   (and (re-search-forward nndoc-article-begin nil t)
  412.        (goto-char (match-beginning 0))))
  413.  
  414. (defun nndoc-mbox-body-end ()
  415.   (let ((beg (point))
  416.     len end)
  417.     (when
  418.     (save-excursion
  419.       (and (re-search-backward nndoc-article-begin nil t)
  420.            (setq end (point))
  421.            (search-forward "\n\n" beg t)
  422.            (re-search-backward
  423.         "^Content-Length:[ \t]*\\([0-9]+\\) *$" end t)
  424.            (setq len (string-to-int (match-string 1)))
  425.            (search-forward "\n\n" beg t)
  426.            (or (= (setq len (+ (point) len)) (point-max))
  427.            (and (< len (point-max))
  428.             (goto-char len)
  429.             (looking-at nndoc-article-begin)))))
  430.       (goto-char len))))
  431.  
  432. (defun nndoc-rnews-body-end ()
  433.   (and (re-search-backward nndoc-article-begin nil t)
  434.        (forward-line 1)
  435.        (goto-char (+ (point) (string-to-int (match-string 1))))))
  436.  
  437. (defun nndoc-transform-clari-briefs (article)
  438.   (goto-char (point-min))
  439.   (when (looking-at " *\\*\\(.*\\)\n")
  440.     (replace-match "" t t))
  441.   (nndoc-generate-clari-briefs-head article))
  442.  
  443. (defun nndoc-generate-clari-briefs-head (article)
  444.   (let ((entry (cdr (assq article nndoc-dissection-alist)))
  445.     subject from)
  446.     (save-excursion
  447.       (set-buffer nndoc-current-buffer)
  448.       (save-restriction
  449.     (narrow-to-region (car entry) (nth 3 entry))
  450.     (goto-char (point-min))
  451.     (when (looking-at " *\\*\\(.*\\)$")
  452.       (setq subject (match-string 1))
  453.       (when (string-match "[ \t]+$" subject)
  454.         (setq subject (substring subject 0 (match-beginning 0)))))
  455.     (when
  456.         (let ((case-fold-search nil))
  457.           (re-search-forward
  458.            "^\t\\([^a-z]+\\(,[^(]+\\)? ([^a-z]+)\\) --" nil t))
  459.       (setq from (match-string 1)))))
  460.     (insert "From: " "clari@clari.net (" (or from "unknown") ")"
  461.         "\nSubject: " (or subject "(no subject)") "\n")))
  462.  
  463. (defun nndoc-babyl-body-begin ()
  464.   (re-search-forward "^\n" nil t)
  465.   (when (looking-at "\*\*\* EOOH \*\*\*")
  466.     (re-search-forward "^\n" nil t)))
  467.  
  468. (defun nndoc-babyl-head-begin ()
  469.   (when (re-search-forward "^[0-9].*\n" nil t)
  470.     (when (looking-at "\*\*\* EOOH \*\*\*")
  471.       (forward-line 1))
  472.     t))
  473.  
  474. (provide 'nndoc)
  475.  
  476. ;;; nndoc.el ends here
  477.